home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / datetim2.pqs / datetim2.pas
Encoding:
Pascal/Delphi Source File  |  1986-10-24  |  2.6 KB  |  108 lines
  1. { routine to read and set date and time. }
  2.  
  3. { each routine requires the following definitions }
  4. { but does not require the other routines.        }
  5.  
  6. type datetimetype = string[8];
  7.      regtype      = record
  8.                       ax,bx,cx,dx,bp,si,di,ds,es,flags:integer
  9.                     end;
  10.  
  11. function date: datetimetype;
  12.   { returns current date in form '08/31/84'. }
  13.  
  14. var reg:     regtype;
  15.     y,m,d,w: datetimetype;
  16.     i:       integer;
  17.  
  18. begin
  19.   reg.ax:=$2A00;
  20.   intr($21,reg);
  21.   str(reg.cx:4,y);
  22.   delete(y,1,2);
  23.   str(hi(reg.dx):2,m);
  24.   str(lo(reg.dx):2,d);
  25.   w:=m + '/' + d + '/' + y;
  26.   for i:=1 to length(w) do if w[i]=' ' then w[i]:='0';
  27.   date:=w
  28. end;
  29.  
  30. function time: datetimetype;
  31.   { returns current time in form '08:13:59'. }
  32.  
  33. var reg:     regtype;
  34.     h,m,s,w: datetimetype;
  35.     i:       integer;
  36.  
  37. begin
  38.   reg.ax:=$2C00;
  39.   intr($21,reg);
  40.   str(hi(reg.cx):2,h);
  41.   str(lo(reg.cx):2,m);
  42.   str(hi(reg.dx):2,s);
  43.   w:=h + ':' + m + ':' + s;
  44.   for i:=i to length(w) do if w[i]=' ' then w[i]:='0';
  45.   time:=w;
  46. end;
  47.  
  48. procedure setdate(x:datetimetype);
  49.   { sets date.  Accepts string in format '08/31/84'. }
  50.  
  51. var reg:            regtype;
  52.     rh,rl,c1,c2,c3: integer;
  53.  
  54. begin
  55.   reg.ax:=$2B00;
  56.   val(x[1]+x[2],rh,c1);    { month goes in DH }
  57.   val(x[4]+x[5],rl,c2);    { day   goes in DL }
  58.   reg.dx:=rh*256 + rl;
  59.   val(x[7]+x[8],rl,c3);    { year  goes in CX }
  60.   reg.cx:=rl + 1900;
  61.   if rl<80 then reg.cx:=reg.cx+100;  { 21st century }
  62.   c1:=c1+c2+c3;            { return codes from VAL }
  63.   if c1=0 then intr($21,reg);
  64.   if c1+lo(reg.ax)<>0 then
  65.     begin
  66.       writeln;
  67.       writeln('Error -- Invalid date, ''',x,'''');
  68.       halt;
  69.     end;
  70. end;
  71.  
  72. procedure settime(x:datetimetype);
  73.   { sets time.  accepts string in format '08:13:59'. }
  74.  
  75. var reg:            regtype;
  76.     rh,rl,c1,c2,c3: integer;
  77.  
  78. begin
  79.   reg.ax:=$2D00;
  80.   val(x[1]+x[2],rh,c1);       { hours   go in CH }
  81.   val(x[4]+x[5],rl,c2);       { minutes go in CL }
  82.   reg.cx:=rh*256+rl;
  83.   val(x[7]+x[8],rh,c3);       { seconds go in DH }
  84.   reg.dx:=rh*256;
  85.   c1:=c1+c2+c3;               { return codes from VAL }
  86.   if c1=0 then intr($21,reg);
  87.   if c1+lo(reg.ax)<>0 then
  88.     begin
  89.       writeln;
  90.       writeln('Error -- Invalid time ''',x,'''');
  91.       halt;
  92.     end;
  93. end;
  94.  
  95.  {  sample program calling DATE, TIME, SETDATE, and SETTIME.
  96.    var x:string[8];
  97.      begin
  98.        writeln(DATE,' ',TIME);
  99.        writeln('What is the date?');
  100.        readln(x);
  101.        setdate(x);
  102.        writeln('What is the time?');
  103.        readln(x);
  104.        settime(x);
  105.  
  106.     end.
  107.  
  108.   }